home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / LIBRARY / PBLIB1 / UNITS / OBJOUT.INC < prev    next >
Text File  |  1994-02-18  |  18KB  |  629 lines
  1.  
  2.  
  3. {SECTION  OUT_object_0 }
  4. Procedure OUT_object_0.HandleFName(fn: string; append : byte);
  5.     begin
  6.     fname      := UpCaseStr(fn);
  7.     if      (fname = '') then fname := 'CON';
  8.     RemoveTrailing(fname,':');
  9.  
  10.     if      (fname = 'LPT1') then devtyp := OUT_typPRT
  11.     else if (fname = 'LPT2') then devtyp := OUT_typPRT
  12.     else if (fname = 'CON')  then devtyp := OUT_typCRT
  13.     else if (fname = 'NUL')  then devtyp := OUT_typNUL
  14.     else devtyp := OUT_typFIL;
  15.     if FileExt(fname) = 'LST' then devtyp := OUT_typPRT;
  16.  
  17.     if      DevTyp = OUT_typPRT then
  18.          begin plen := 59; llen := 90; loff := 5; end
  19.     else if DevTyp = OUT_typFIL then
  20.          begin plen := 32700; llen := 131; loff := 0; end
  21.     else if DevTyp = OUT_typNUL then
  22.          begin plen := 32700; llen := 80; loff := 0; end
  23.     else begin plen := 24; llen := 79; loff := 0; end;
  24.     end;
  25.  
  26.  
  27. Procedure OUT_object_0.LISTInit(fn: string; append : byte);
  28.     begin
  29.     HandleFName(fn,append);
  30.     Init(fname,devtyp,append,plen,llen,loff);
  31.     end;
  32.  
  33.  
  34. Procedure OUT_object_0.Init(fn: string; dtyp, append : byte;
  35.                                   pl, lw : integer; off : byte);
  36.     begin
  37.     noprint    := false;
  38.     opened     := false;
  39.     err        := 0;
  40.     indent     := 0;
  41.     compressed := false;
  42.     landscape  := false;
  43.     PrinterInitted := false;
  44.  
  45.     fname      := fn;
  46.     devtyp     := dtyp;
  47.     app        := append;
  48.     llen       := lw;
  49.     plen       := pl;
  50.     SetOffset(off);
  51.     SetINdent(indent);
  52.     ResetCounts;
  53.     end;
  54.  
  55.  
  56. Procedure OUT_object_0.LISTOpen;
  57.     begin
  58.     {$I-} close(f); {$I+}   {just make sure}
  59.     err    := IOResult;
  60.     opened := false;
  61.     err    := 0;
  62.  
  63.     case DevTyp of
  64.          OUT_typCRT  : begin
  65.                   {$I-} assign(f,''); {$I+}
  66.                    err := IOResult;
  67.                    if err = 0 then
  68.                         begin
  69.                         {$I-} rewrite(f); {$I+}
  70.                         err := IOResult;
  71.                         end;
  72.                    if err <> 0 then
  73.                         writeln('Unable to open CRT  err=',err);
  74.                    end;
  75.  
  76.          OUT_typPRT  : begin
  77.                   {$I-} assign(lst,fname); {$I+}
  78.                    err := IOResult;
  79.                    if err = 0 then
  80.                         begin
  81.                         {$I-} rewrite(lst); {$I+}
  82.                         err := IOResult;
  83.                         end;
  84.                    if err <> 0 then
  85.                         writeln('Unable to open PRINTER  err=',err);
  86.                    end;
  87.  
  88.          OUT_typFIL  : begin
  89.                   {$I-} assign(f,fname); {$I+}
  90.                    err := IOResult;
  91.                    if err = 0 then
  92.                         begin
  93.                         if app = OUT_typREWRITE then
  94.                              begin
  95.                              {$I-} rewrite(f); {$I+}
  96.                              err := IOResult;
  97.                              end
  98.                         else if app = OUT_typAPPEND then
  99.                              begin
  100.                              {$I-} append(f); {$I+}
  101.                              err := IOResult;
  102.                              if err = 2 then
  103.                                   begin
  104.                                  {$I-} rewrite(f); {$I+}
  105.                                   err := IOResult;
  106.                                   app := OUT_typREWRITE;
  107.                                   end;
  108.                              end;
  109.                         end;
  110.                    if err <> 0 then
  111.                         writeln('Unable to open FILE  err=',err);
  112.                    end;
  113.          end;
  114.     if err = 0 then opened := true;
  115.     end;
  116.  
  117.  
  118. Procedure OUT_object_0.SetOffset( i : byte);  {all lines on page}
  119.     begin
  120.     loff := i;
  121.     loffstr := conststr(' ',loff);
  122.     currllen := llen - (loff + indent);
  123.     end;
  124.  
  125.  
  126. Procedure OUT_object_0.SetIndent( i : byte);  {all lines on page}
  127.     begin
  128.     indentstr := '';
  129.     indent := i;
  130.     indentstr := {'<'+integerstr(i,2)+'>'}+conststr(' ',indent);
  131.     currllen := llen - (loff + indent);
  132.     end;
  133.  
  134.  
  135. Procedure OUT_object_0.ResetCounts;
  136.     begin
  137.     currline   := 1;
  138.     currpage   := 1;
  139.     linesprinted := 0;
  140.     linesmax     := 999999;
  141.     end;
  142.  
  143.  
  144.  
  145. Procedure OUT_object_0.SetCompressed;
  146.      begin
  147.      if devtyp <> OUT_typPRT then exit;
  148.      compressed := true;
  149.      printerinitted := false;
  150.      if landscape then
  151.           begin llen := 172; plen := 58; loff := 6; end
  152.      else begin llen := 130; plen := 78; loff := 12; end;
  153.      loffstr := conststr(' ',loff);
  154.      currllen := llen - (loff + indent);
  155.      end;
  156.  
  157.  
  158. Procedure OUT_object_0.SetLandscape;
  159.      begin
  160.      if devtyp <> OUT_typPRT then exit;
  161.      landscape := true;
  162.      printerinitted := false;
  163.      if compressed then
  164.           begin llen := 172; plen := 58; loff := 6; end
  165.      else begin llen := 120; plen := 43; loff := 5; end;
  166.      loffstr := conststr(' ',loff);
  167.      currllen := llen - (loff + indent);
  168.      end;
  169.  
  170.  
  171. Procedure OUT_object_0.pause;
  172. var s : string;
  173.     begin
  174.     if nopause then exit;
  175.     if DevTyp = OUT_typCRT then
  176.          begin
  177.          if linesprinted > linesmax then exit;
  178.          write('pause'); readln(s);
  179.          if ord(s[1]) = 27 then linesprinted := linesmax + 1;
  180.          end;
  181.     end;
  182.  
  183.  
  184. Procedure OUT_object_0.SetNoPause;
  185.     begin
  186.     nopause := true;
  187.     end;
  188.  
  189.  
  190. Procedure OUT_object_0.formfeed;
  191.     begin
  192.     currline := 1;
  193.     if not opened then exit;
  194.     if noprint then exit;
  195.     case DevTyp of
  196.          OUT_typCRT  : begin
  197.                    pause;
  198.                    end;
  199.  
  200.          OUT_typPRT  : begin
  201.                   {$I-} write(lst,^L); {$I+}
  202.                    err := IOResult;
  203.                    end;
  204.          end;
  205.     end;
  206.  
  207.  
  208. Procedure OUT_object_0.InitPrinter;
  209. var s : string;
  210.      begin
  211.      PrinterInitted := true;
  212.      if devtyp = OUT_typPRT then
  213.           begin
  214.           s := chr(27) + 'E';        { RESET }
  215.           write(lst,s);
  216.           if landscape then
  217.                begin
  218.                s := chr(27) + '&l1O';        { Landscape }
  219.                write(lst,s);
  220.                end;
  221.           if compressed then
  222.                begin
  223.                s := chr(27) + '(s16.66h(s2B'+
  224.                     chr(27)+'&l8D'; { 132 col,demibold,8lpi }
  225.                write(lst,s);
  226.                end;
  227.           end;
  228.       end;
  229.  
  230.  
  231. Procedure OUT_object_0.OutERRNoCR(s : string);  { Physical I/O level }
  232.     begin
  233.     err := 0;
  234.     if not opened then exit;
  235.     if not printerinitted then InitPrinter;
  236.     case DevTyp of
  237.            OUT_typCRT  : begin
  238.                     {$I-} write(s); {$I+}
  239.                      err := IOResult;
  240.                      end;
  241.  
  242.            OUT_typPRT  : begin
  243.                     {$I-} write(lst,s); {$I+}
  244.                      err := IOResult;
  245.                      end;
  246.  
  247.            OUT_typFIL  : begin
  248.                     {$I-} write(f,s); {$I+}
  249.                      err := IOResult;
  250.                      end;
  251.            end;
  252. {    if err <> 0 then writeln('OutERRNoCR ',err);}
  253.     end;
  254.  
  255.  
  256. Procedure OUT_object_0.OutERR(s : string);  { Physical I/O level }
  257. var line : string;
  258.     i    : integer;
  259.     begin
  260.     err := 0;
  261.     if not opened then exit;
  262.     if linesprinted > linesmax then exit;
  263.     if noprint then exit;
  264.     line := leftstr(loffstr+indentstr+s,llen-1);
  265.     RemoveTrailing(line,' ');
  266.     case DevTyp of
  267.            OUT_typCRT  : begin
  268.                     {$I-} writeln(line); {$I+}
  269.                      err := IOResult;
  270.                      end;
  271.  
  272.            OUT_typPRT  : begin
  273.                     {$I-} writeln(lst,line); {$I+}
  274.                      err := IOResult;
  275.                      if err <> 0 then
  276.                          begin
  277.                          while err = 152 do   { LJ memory full? }
  278.                              begin
  279.                              writeln('Error 152 printing (',currpage,',',
  280.                                       currline,') [',s,']');
  281.                        {$I-} writeln(lst,line); {$I+}
  282.                              err := IOResult;
  283.                              end;
  284.                         end;
  285.                      end;
  286.  
  287.            OUT_typFIL  : begin
  288.                     {$I-} writeln(f,line); {$I+}
  289.                      err := IOResult;
  290.                      end;
  291.            end;
  292. {    if err <> 0 then writeln('OutERR ',err);}
  293.     end;
  294.  
  295.  
  296. Procedure OUT_object_0.OutHeader;
  297.      begin
  298.      if (devtyp = OUT_typPRT) and landscape then OutErr(' ');
  299.      currline := 1;
  300.      end;
  301.  
  302.  
  303. Procedure OUT_object_0.OutFooter;
  304.      begin
  305.      if currline > 1 then formfeed;
  306.      inc(currpage);
  307.      end;
  308.  
  309.  
  310. Procedure OUT_object_0.Out(s : string);   { Logical I/O level }
  311.      begin
  312.      if linesprinted > linesmax then exit;
  313.      if (devtyp = OUT_typPRT) and (not printerinitted) then InitPrinter;
  314.      if currline <= 1 then OutHeader;
  315.      OutERR(s);
  316.      inc(currline);
  317.      if currline > plen then OutFooter;
  318.      end;
  319.  
  320.  
  321.  
  322. Procedure OUT_object_0.DoneWithPage;
  323. var i,j : integer;
  324.      begin
  325.      if currline = 1 then exit;
  326.      if devtyp = OUT_typPRT then
  327.           begin
  328.           j := currline;
  329.           for i := j to plen do
  330.                begin
  331.                OutErr(' ');
  332.                inc(currline);
  333.                end;
  334.           end;
  335.      OutFooter;
  336.      end;
  337.  
  338.  
  339. Procedure OUT_object_0.done;
  340. var s : string;
  341.      begin
  342.      nopause := true;
  343.      if currline > 1 then DoneWithPage;
  344.      if devtyp = OUT_typPRT then
  345.           begin
  346.           s := chr(27) + 'E';        { RESET }
  347.           write(lst,s);
  348.           end;
  349.      if devtyp = OUT_typPRT then
  350.           begin
  351.           {$I-} close(lst); {$I+}
  352.           end
  353.      else if devtyp <> OUT_typCRT then
  354.           begin
  355.           {$I-} close(f); {$I+}
  356.           end;
  357.      err := IOResult;
  358.      opened := false;
  359.      end;
  360.  
  361.  
  362.  
  363. {SECTION  OUT_object_1 }
  364. {All the fancy stuff}
  365. Procedure OUT_object_1.LISTInit(fn: string; append : byte);
  366.     begin
  367.     HandleFName(fn,devtyp);
  368.     Init(fname,devtyp,append,plen,llen,loff);
  369.     end;
  370.  
  371.  
  372. Procedure OUT_object_1.Init(fn: string; dtyp, append : byte;
  373.                                   pl, lw : integer; off : byte);
  374.     begin
  375.     OUT_object_0.init(fn,dtyp,append,pl,lw,off);
  376.     alldone    := false;
  377.     header1spec  := '@DATE||Page @PAGE'; header2spec := ''; header3spec := '';
  378.     footer1spec  := ''; footer2spec := '';
  379.     pagelabel1   := ''; pagelabel2  := ''; pagelabel3 := '';
  380.     joinflag     := false;
  381.     joinwidth    := currllen;
  382.     joinlinehold := '';
  383.     end;
  384.  
  385.  
  386. Procedure OUT_object_1.SetHeaders(h1spec,h2spec,h3spec,f1spec,f2spec : string);
  387.     begin
  388.     header1spec := h1spec;
  389.     header2spec := h2spec;
  390.     header3spec := h3spec;
  391.     footer1spec := f1spec;
  392.     footer2spec := f2spec;
  393.     if footer1spec <> '' then dec(plen);
  394.     if footer2spec <> '' then dec(plen);
  395.     end;
  396.  
  397.  
  398.  
  399. Function OUT_object_1.SpecialStr(str : string) : string; {header/Footer}
  400. var s : string;
  401.      begin
  402.      s := UpCaseStr(str);
  403.      if      s = '@DATE'     then s := leftstr(FormatDTime,8)
  404.      else if s = '@DTIME'    then s := leftstr(FormatDTime,14)
  405.      else if s = '@TIME'     then s := copy(FormatDTime,10,5)
  406.      else if s = '@PAGE'     then s := trimstr(integerstr(currpage,3))
  407.      else if s = '@LABEL1'   then s := pagelabel1
  408.      else if s = '@LABEL2'   then s := pagelabel2
  409.      else if s = '@LABEL3'   then s := pagelabel3
  410.      else if s = '@PROGID'   then s := pProgID
  411.      else if s = '@FILE'     then s := pCurrFName
  412.      else begin s := str; end;
  413.      {writeln('SpecialStr in= [',str,']   out= [',s,']');}
  414.      SpecialStr := s;
  415.      end;
  416.  
  417.  
  418. Function OUT_object_1.FmtHeaderPiece(spec : string) : string;
  419. var s,s1,s2, result,r1 : string;
  420.     i       : integer;
  421.     ch      : char;
  422.      begin
  423.      result := '';
  424.      s := spec;
  425.      PatchStr(s,' ','~');
  426.     { writeln('FmtHeaderPiece [',s,']');}
  427.      while length(s) > 0 do
  428.           begin
  429.           r1 := '';
  430.           s1 := GetLeftStr(s,'@');
  431.           if s <> '' then
  432.                begin
  433.               { writeln('Found @  s1 [',s1,']  s [',s,']');}
  434.                result := result + s1;                  { up to @ }
  435.                s1 := GetLeftStr(s,'~');          { get the @v }
  436.                result := result + SpecialStr('@'+s1);  { processed @v }
  437.                s := '~' + s;                           { '@v ' }
  438.                end
  439.           else result := result + s1;
  440.           end;
  441.      PatchStr(result,'~',' ');
  442.      FmtHeaderPiece := result;
  443.      end;
  444.  
  445.  
  446. Function OUT_object_1.pFmtHeader(spec : string; width : integer) : string;
  447. {  Header/Footer specification --> '<2>|<1>|<3>' where
  448.      <n>   = text (delimited by the | or end of string    and/or
  449.            = @keyword         such as @today or @page     and/or
  450.            = @variable        set by \set @variable = '...' <- not ready
  451. }
  452. var s,result : string;
  453.     s1,s2,s3 : string[60];
  454.     i        : integer;
  455.     ch       : char;
  456.      begin
  457.      result := '';
  458.      s := spec;
  459.      if (s[1] = '''') or (s[1]='"')  then
  460.          begin
  461.          delete(s,1,1);
  462.          delete(s,length(s),1);
  463.          end;
  464.      s2 := GetLeftStr(s,'|');
  465.      s1 := GetLeftStr(s,'|');
  466.      s3 := GetLeftStr(s,'|');
  467.      s := ' ';
  468.  
  469.      if length(s1) > 0 then        { center }
  470.           begin
  471.           s1 := FmtHeaderPiece(s1);
  472.           result := CenterStr(s1,width);
  473.           end
  474.      else result := ' ';
  475.      if length(s2) > 0 then        { left }
  476.           begin
  477.           s2 := FmtHeaderPiece(s2);
  478.           result := MergeStr(result,1,s2);
  479.           end;
  480.      if length(s3) > 0 then        { left }
  481.           begin
  482.           s3 := FmtHeaderPiece(s3);
  483.           result := MergeStr(result,(width-length(s3)),s3);
  484.           end;
  485.      pFmtHeader := result;
  486.      end;
  487.  
  488. {PAGE}
  489.  
  490.  
  491.  
  492. Procedure OUT_object_1.OutHeader;
  493.      begin
  494.      currline := 1;
  495.      if (devtyp = OUT_typPRT) and landscape then OutErr(' ');
  496.      if header1spec <> '' then
  497.          begin
  498.          OutERR(pFmtHeader(header1spec,currllen));
  499.          inc(currline);
  500.          end;
  501.      if header2spec <> '' then
  502.          begin
  503.          OutERR(pFmtHeader(header2spec,currllen));
  504.          inc(currline);
  505.          end;
  506.      if header3spec <> '' then
  507.          begin
  508.          OutERR(pFmtHeader(header3spec,currllen));
  509.          inc(currline);
  510.          end;
  511.      end;
  512.  
  513.  
  514. Procedure OUT_object_1.OutFooter;
  515.      begin
  516.      if footer2spec <> '' then
  517.          begin
  518.          OutERR(pFmtHeader(footer2spec,currllen));
  519.          end;
  520.      if footer1spec <> '' then
  521.          begin
  522.          OutERR(pFmtHeader(footer1spec,currllen));
  523.          end;
  524.      formfeed;
  525.      inc(currpage);
  526.      end;
  527.  
  528.  
  529. Procedure OUT_object_1.Out(s : string);   { Logical I/O level }
  530.      begin
  531.      if linesprinted > linesmax then exit;
  532.      if (devtyp = OUT_typPRT) and (not printerinitted) then InitPrinter;
  533.      if currline <= 1 then OutHeader;
  534.      OutERR(s);
  535.      inc(currline);
  536.      if currline > plen then OutFooter;
  537.      end;
  538.  
  539.  
  540.  
  541. Procedure OUT_object_1.DoneWithPage;
  542. var i,j : integer;
  543.      begin
  544.      if currline = 1 then exit;
  545.      if devtyp = OUT_typPRT then
  546.           begin
  547.           j := currline;
  548.           for i := j to plen do
  549.                begin
  550.                OutErr(' ');
  551.                inc(currline);
  552.                end;
  553.           end;
  554.      OutFooter;
  555.      end;
  556.  
  557.  
  558. Procedure OUT_object_1.done;
  559. var s : string;
  560.      begin
  561.      nopause := true;
  562.      alldone := true;
  563.      flushjoin(true); { if needed }
  564.      if currline > 1 then DoneWithPage;
  565.      if devtyp = OUT_typPRT then
  566.           begin
  567.           s := chr(27) + 'E';        { RESET }
  568.           write(lst,s);
  569.           end;
  570.      if devtyp = OUT_typPRT then
  571.           begin
  572.           {$I-} close(lst); {$I+}
  573.           end
  574.      else if devtyp <> OUT_typCRT then
  575.           begin
  576.           {$I-} close(f); {$I+}
  577.           end;
  578.      err := IOResult;
  579.      if err <> 0 then writeln('Done - CLOSE error= ',err);
  580.      opened := false;
  581.      end;
  582.  
  583.  
  584. {PAGE JOIN}
  585.  
  586.  
  587. Procedure OUT_object_1.FlushJoin(joindone : boolean);
  588.      begin
  589.      if not joinflag then exit;
  590.      if length(joinlinehold) > 0 then
  591.           begin
  592.           out(joinlinehold);
  593.           joinlinehold := '';
  594.           end;
  595.      if joindone then joinflag := false;
  596.      end;
  597.  
  598.  
  599. Procedure OUT_object_1.OutJoin(line : string);
  600. var i : integer;
  601.      begin
  602.      if joinflag then
  603.           begin
  604.           i := 0;
  605.           if (length(joinlinehold) > 0) then
  606.                joinlinehold := joinlinehold + ' ' + line
  607.           else joinlinehold := line;
  608.           while (length(joinlinehold) > joinwidth) do
  609.                begin
  610.                out(BreakLine(joinlinehold,joinwidth));
  611.                inc(i);
  612.                if i > 20 then
  613.                     begin
  614.                     writeln('*** join failure [',joinlinehold,']');
  615.                     joinlinehold := ''; {emergency exit}
  616.                     end;
  617.                end;
  618.           trim(joinlinehold);
  619.           if line = '' then
  620.                begin
  621.                flushjoin(false);
  622.                out(' ');
  623.                end;
  624.           end
  625.      else out(line);
  626.      end;
  627.  
  628.  
  629.